home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / File / Spec / VMS.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  15.2 KB  |  537 lines
  1. package File::Spec::VMS;
  2.  
  3. use strict;
  4. use vars qw(@ISA $VERSION);
  5. require File::Spec::Unix;
  6.  
  7. $VERSION = '3.2501';
  8.  
  9. @ISA = qw(File::Spec::Unix);
  10.  
  11. use File::Basename;
  12. use VMS::Filespec;
  13.  
  14. =head1 NAME
  15.  
  16. File::Spec::VMS - methods for VMS file specs
  17.  
  18. =head1 SYNOPSIS
  19.  
  20.  require File::Spec::VMS; # Done internally by File::Spec if needed
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. See File::Spec::Unix for a documentation of the methods provided
  25. there. This package overrides the implementation of these methods, not
  26. the semantics.
  27.  
  28. =over 4
  29.  
  30. =item canonpath (override)
  31.  
  32. Removes redundant portions of file specifications according to VMS syntax.
  33.  
  34. =cut
  35.  
  36. sub canonpath {
  37.     my($self,$path) = @_;
  38.  
  39.     return undef unless defined $path;
  40.  
  41.     if ($path =~ m|/|) { # Fake Unix
  42.       my $pathify = $path =~ m|/\Z(?!\n)|;
  43.       $path = $self->SUPER::canonpath($path);
  44.       if ($pathify) { return vmspath($path); }
  45.       else          { return vmsify($path);  }
  46.     }
  47.     else {
  48.     $path =~ tr/<>/[]/;            # < and >       ==> [ and ]
  49.     $path =~ s/\]\[\./\.\]\[/g;        # ][.        ==> .][
  50.     $path =~ s/\[000000\.\]\[/\[/g;        # [000000.][    ==> [
  51.     $path =~ s/\[000000\./\[/g;        # [000000.    ==> [
  52.     $path =~ s/\.\]\[000000\]/\]/g;        # .][000000]    ==> ]
  53.     $path =~ s/\.\]\[/\./g;            # foo.][bar     ==> foo.bar
  54.     1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
  55.                         # That loop does the following
  56.                         # with any amount of dashes:
  57.                         # .-.-.        ==> .--.
  58.                         # [-.-.        ==> [--.
  59.                         # .-.-]        ==> .--]
  60.                         # [-.-]        ==> [--]
  61.     1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
  62.                         # That loop does the following
  63.                         # with any amount (minimum 2)
  64.                         # of dashes:
  65.                         # .foo.--.    ==> .-.
  66.                         # .foo.--]    ==> .-]
  67.                         # [foo.--.    ==> [-.
  68.                         # [foo.--]    ==> [-]
  69.                         #
  70.                         # And then, the remaining cases
  71.     $path =~ s/\[\.-/[-/;            # [.-        ==> [-
  72.     $path =~ s/\.[^\]\.]+\.-\./\./g;    # .foo.-.    ==> .
  73.     $path =~ s/\[[^\]\.]+\.-\./\[/g;    # [foo.-.    ==> [
  74.     $path =~ s/\.[^\]\.]+\.-\]/\]/g;    # .foo.-]    ==> ]
  75.     $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-]       ==> [000000]
  76.     $path =~ s/\[\]// unless $path eq '[]';    # []        ==>
  77.     return $path;
  78.     }
  79. }
  80.  
  81. =item catdir (override)
  82.  
  83. Concatenates a list of file specifications, and returns the result as a
  84. VMS-syntax directory specification.  No check is made for "impossible"
  85. cases (e.g. elements other than the first being absolute filespecs).
  86.  
  87. =cut
  88.  
  89. sub catdir {
  90.     my $self = shift;
  91.     my $dir = pop;
  92.     my @dirs = grep {defined() && length()} @_;
  93.  
  94.     my $rslt;
  95.     if (@dirs) {
  96.     my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  97.     my ($spath,$sdir) = ($path,$dir);
  98.     $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; 
  99.     $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
  100.     $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  101.  
  102.     # Special case for VMS absolute directory specs: these will have had device
  103.     # prepended during trip through Unix syntax in eliminate_macros(), since
  104.     # Unix syntax has no way to express "absolute from the top of this device's
  105.     # directory tree".
  106.     if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
  107.     }
  108.     else {
  109.     if    (not defined $dir or not length $dir) { $rslt = ''; }
  110.     elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
  111.     else                                        { $rslt = vmspath($dir); }
  112.     }
  113.     return $self->canonpath($rslt);
  114. }
  115.  
  116. =item catfile (override)
  117.  
  118. Concatenates a list of file specifications, and returns the result as a
  119. VMS-syntax file specification.
  120.  
  121. =cut
  122.  
  123. sub catfile {
  124.     my $self = shift;
  125.     my $file = $self->canonpath(pop());
  126.     my @files = grep {defined() && length()} @_;
  127.  
  128.     my $rslt;
  129.     if (@files) {
  130.     my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
  131.     my $spath = $path;
  132.     $spath =~ s/\.dir\Z(?!\n)//;
  133.     if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
  134.         $rslt = "$spath$file";
  135.     }
  136.     else {
  137.         $rslt = $self->eliminate_macros($spath);
  138.         $rslt = vmsify($rslt.((defined $rslt) && ($rslt ne '') ? '/' : '').unixify($file));
  139.     }
  140.     }
  141.     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
  142.     return $self->canonpath($rslt);
  143. }
  144.  
  145.  
  146. =item curdir (override)
  147.  
  148. Returns a string representation of the current directory: '[]'
  149.  
  150. =cut
  151.  
  152. sub curdir {
  153.     return '[]';
  154. }
  155.  
  156. =item devnull (override)
  157.  
  158. Returns a string representation of the null device: '_NLA0:'
  159.  
  160. =cut
  161.  
  162. sub devnull {
  163.     return "_NLA0:";
  164. }
  165.  
  166. =item rootdir (override)
  167.  
  168. Returns a string representation of the root directory: 'SYS$DISK:[000000]'
  169.  
  170. =cut
  171.  
  172. sub rootdir {
  173.     return 'SYS$DISK:[000000]';
  174. }
  175.  
  176. =item tmpdir (override)
  177.  
  178. Returns a string representation of the first writable directory
  179. from the following list or '' if none are writable:
  180.  
  181.     sys$scratch:
  182.     $ENV{TMPDIR}
  183.  
  184. Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
  185. is tainted, it is not used.
  186.  
  187. =cut
  188.  
  189. my $tmpdir;
  190. sub tmpdir {
  191.     return $tmpdir if defined $tmpdir;
  192.     $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
  193. }
  194.  
  195. =item updir (override)
  196.  
  197. Returns a string representation of the parent directory: '[-]'
  198.  
  199. =cut
  200.  
  201. sub updir {
  202.     return '[-]';
  203. }
  204.  
  205. =item case_tolerant (override)
  206.  
  207. VMS file specification syntax is case-tolerant.
  208.  
  209. =cut
  210.  
  211. sub case_tolerant {
  212.     return 1;
  213. }
  214.  
  215. =item path (override)
  216.  
  217. Translate logical name DCL$PATH as a searchlist, rather than trying
  218. to C<split> string value of C<$ENV{'PATH'}>.
  219.  
  220. =cut
  221.  
  222. sub path {
  223.     my (@dirs,$dir,$i);
  224.     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
  225.     return @dirs;
  226. }
  227.  
  228. =item file_name_is_absolute (override)
  229.  
  230. Checks for VMS directory spec as well as Unix separators.
  231.  
  232. =cut
  233.  
  234. sub file_name_is_absolute {
  235.     my ($self,$file) = @_;
  236.     # If it's a logical name, expand it.
  237.     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
  238.     return scalar($file =~ m!^/!s             ||
  239.           $file =~ m![<\[][^.\-\]>]!  ||
  240.           $file =~ /:[^<\[]/);
  241. }
  242.  
  243. =item splitpath (override)
  244.  
  245. Splits using VMS syntax.
  246.  
  247. =cut
  248.  
  249. sub splitpath {
  250.     my($self,$path) = @_;
  251.     my($dev,$dir,$file) = ('','','');
  252.  
  253.     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
  254.     return ($1 || '',$2 || '',$3);
  255. }
  256.  
  257. =item splitdir (override)
  258.  
  259. Split dirspec using VMS syntax.
  260.  
  261. =cut
  262.  
  263. sub splitdir {
  264.     my($self,$dirspec) = @_;
  265.     my @dirs = ();
  266.     return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
  267.     $dirspec =~ tr/<>/[]/;            # < and >    ==> [ and ]
  268.     $dirspec =~ s/\]\[\./\.\]\[/g;        # ][.        ==> .][
  269.     $dirspec =~ s/\[000000\.\]\[/\[/g;        # [000000.][    ==> [
  270.     $dirspec =~ s/\[000000\./\[/g;        # [000000.    ==> [
  271.     $dirspec =~ s/\.\]\[000000\]/\]/g;        # .][000000]    ==> ]
  272.     $dirspec =~ s/\.\]\[/\./g;            # foo.][bar    ==> foo.bar
  273.     while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
  274.                         # That loop does the following
  275.                         # with any amount of dashes:
  276.                         # .--.        ==> .-.-.
  277.                         # [--.        ==> [-.-.
  278.                         # .--]        ==> .-.-]
  279.                         # [--]        ==> [-.-]
  280.     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
  281.     $dirspec =~ s/^(\[|<)\./$1/;
  282.     @dirs = split /(?<!\^)\./, vmspath($dirspec);
  283.     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
  284.     @dirs;
  285. }
  286.  
  287.  
  288. =item catpath (override)
  289.  
  290. Construct a complete filespec using VMS syntax
  291.  
  292. =cut
  293.  
  294. sub catpath {
  295.     my($self,$dev,$dir,$file) = @_;
  296.     
  297.     # We look for a volume in $dev, then in $dir, but not both
  298.     my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
  299.     $dev = $dir_volume unless length $dev;
  300.     $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
  301.     
  302.     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
  303.     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
  304.     if (length($dev) or length($dir)) {
  305.       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
  306.       $dir = vmspath($dir);
  307.     }
  308.     "$dev$dir$file";
  309. }
  310.  
  311. =item abs2rel (override)
  312.  
  313. Use VMS syntax when converting filespecs.
  314.  
  315. =cut
  316.  
  317. sub abs2rel {
  318.     my $self = shift;
  319.     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
  320.         if grep m{/}, @_;
  321.  
  322.     my($path,$base) = @_;
  323.     $base = $self->_cwd() unless defined $base and length $base;
  324.  
  325.     for ($path, $base) { $_ = $self->canonpath($_) }
  326.  
  327.     # Are we even starting $path on the same (node::)device as $base?  Note that
  328.     # logical paths or nodename differences may be on the "same device" 
  329.     # but the comparison that ignores device differences so as to concatenate 
  330.     # [---] up directory specs is not even a good idea in cases where there is 
  331.     # a logical path difference between $path and $base nodename and/or device.
  332.     # Hence we fall back to returning the absolute $path spec
  333.     # if there is a case blind device (or node) difference of any sort
  334.     # and we do not even try to call $parse() or consult %ENV for $trnlnm()
  335.     # (this module needs to run on non VMS platforms after all).
  336.     
  337.     my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
  338.     my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
  339.     return $path unless lc($path_volume) eq lc($base_volume);
  340.  
  341.     for ($path, $base) { $_ = $self->rel2abs($_) }
  342.  
  343.     # Now, remove all leading components that are the same
  344.     my @pathchunks = $self->splitdir( $path_directories );
  345.     my $pathchunks = @pathchunks;
  346.     unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
  347.     my @basechunks = $self->splitdir( $base_directories );
  348.     my $basechunks = @basechunks;
  349.     unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
  350.  
  351.     while ( @pathchunks && 
  352.             @basechunks && 
  353.             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
  354.           ) {
  355.         shift @pathchunks ;
  356.         shift @basechunks ;
  357.     }
  358.  
  359.     # @basechunks now contains the directories to climb out of,
  360.     # @pathchunks now has the directories to descend in to.
  361.     if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
  362.       $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
  363.     }
  364.     else {
  365.       $path_directories = join '.', @pathchunks;
  366.     }
  367.     $path_directories = '['.$path_directories.']';
  368.     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
  369. }
  370.  
  371.  
  372. =item rel2abs (override)
  373.  
  374. Use VMS syntax when converting filespecs.
  375.  
  376. =cut
  377.  
  378. sub rel2abs {
  379.     my $self = shift ;
  380.     my ($path,$base ) = @_;
  381.     return undef unless defined $path;
  382.     if ($path =~ m/\//) {
  383.     $path = ( -d $path || $path =~ m/\/\z/  # educated guessing about
  384.            ? vmspath($path)             # whether it's a directory
  385.            : vmsify($path) );
  386.     }
  387.     $base = vmspath($base) if defined $base && $base =~ m/\//;
  388.     # Clean up and split up $path
  389.     if ( ! $self->file_name_is_absolute( $path ) ) {
  390.         # Figure out the effective $base and clean it up.
  391.         if ( !defined( $base ) || $base eq '' ) {
  392.             $base = $self->_cwd;
  393.         }
  394.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  395.             $base = $self->rel2abs( $base ) ;
  396.         }
  397.         else {
  398.             $base = $self->canonpath( $base ) ;
  399.         }
  400.  
  401.         # Split up paths
  402.         my ( $path_directories, $path_file ) =
  403.             ($self->splitpath( $path ))[1,2] ;
  404.  
  405.         my ( $base_volume, $base_directories ) =
  406.             $self->splitpath( $base ) ;
  407.  
  408.         $path_directories = '' if $path_directories eq '[]' ||
  409.                                   $path_directories eq '<>';
  410.         my $sep = '' ;
  411.         $sep = '.'
  412.             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
  413.                  $path_directories =~ m{^[^.\[<]}s
  414.             ) ;
  415.         $base_directories = "$base_directories$sep$path_directories";
  416.         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
  417.  
  418.         $path = $self->catpath( $base_volume, $base_directories, $path_file );
  419.    }
  420.  
  421.     return $self->canonpath( $path ) ;
  422. }
  423.  
  424.  
  425. # eliminate_macros() and fixpath() are MakeMaker-specific methods
  426. # which are used inside catfile() and catdir().  MakeMaker has its own
  427. # copies as of 6.06_03 which are the canonical ones.  We leave these
  428. # here, in peace, so that File::Spec continues to work with MakeMakers
  429. # prior to 6.06_03.
  430. # 
  431. # Please consider these two methods deprecated.  Do not patch them,
  432. # patch the ones in ExtUtils::MM_VMS instead.
  433. sub eliminate_macros {
  434.     my($self,$path) = @_;
  435.     return '' unless (defined $path) && ($path ne '');
  436.     $self = {} unless ref $self;
  437.  
  438.     if ($path =~ /\s/) {
  439.       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
  440.     }
  441.  
  442.     my($npath) = unixify($path);
  443.     my($complex) = 0;
  444.     my($head,$macro,$tail);
  445.  
  446.     # perform m##g in scalar context so it acts as an iterator
  447.     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
  448.         if ($self->{$2}) {
  449.             ($head,$macro,$tail) = ($1,$2,$3);
  450.             if (ref $self->{$macro}) {
  451.                 if (ref $self->{$macro} eq 'ARRAY') {
  452.                     $macro = join ' ', @{$self->{$macro}};
  453.                 }
  454.                 else {
  455.                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  456.                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  457.                     $macro = "\cB$macro\cB";
  458.                     $complex = 1;
  459.                 }
  460.             }
  461.             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
  462.             $npath = "$head$macro$tail";
  463.         }
  464.     }
  465.     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
  466.     $npath;
  467. }
  468.  
  469. # Deprecated.  See the note above for eliminate_macros().
  470. sub fixpath {
  471.     my($self,$path,$force_path) = @_;
  472.     return '' unless $path;
  473.     $self = bless {} unless ref $self;
  474.     my($fixedpath,$prefix,$name);
  475.  
  476.     if ($path =~ /\s/) {
  477.       return join ' ',
  478.              map { $self->fixpath($_,$force_path) }
  479.          split /\s+/, $path;
  480.     }
  481.  
  482.     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
  483.         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
  484.             $fixedpath = vmspath($self->eliminate_macros($path));
  485.         }
  486.         else {
  487.             $fixedpath = vmsify($self->eliminate_macros($path));
  488.         }
  489.     }
  490.     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
  491.         my($vmspre) = $self->eliminate_macros("\$($prefix)");
  492.         # is it a dir or just a name?
  493.         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
  494.         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  495.         $fixedpath = vmspath($fixedpath) if $force_path;
  496.     }
  497.     else {
  498.         $fixedpath = $path;
  499.         $fixedpath = vmspath($fixedpath) if $force_path;
  500.     }
  501.     # No hints, so we try to guess
  502.     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
  503.         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
  504.     }
  505.  
  506.     # Trim off root dirname if it's had other dirs inserted in front of it.
  507.     $fixedpath =~ s/\.000000([\]>])/$1/;
  508.     # Special case for VMS absolute directory specs: these will have had device
  509.     # prepended during trip through Unix syntax in eliminate_macros(), since
  510.     # Unix syntax has no way to express "absolute from the top of this device's
  511.     # directory tree".
  512.     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
  513.     $fixedpath;
  514. }
  515.  
  516.  
  517. =back
  518.  
  519. =head1 COPYRIGHT
  520.  
  521. Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  522.  
  523. This program is free software; you can redistribute it and/or modify
  524. it under the same terms as Perl itself.
  525.  
  526. =head1 SEE ALSO
  527.  
  528. See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  529. implementation of these methods, not the semantics.
  530.  
  531. An explanation of VMS file specs can be found at
  532. L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
  533.  
  534. =cut
  535.  
  536. 1;
  537.